home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1996 #15
/
Monster Media Number 15 (Monster Media)(July 1996).ISO
/
prog_d
/
isamexpt.zip
/
NUMCTRL.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-04-05
|
18KB
|
688 lines
unit NumCtrl;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Menus, DsgnIntF;
{ string edit component }
type
TCustomStrEdit = class (TCustomEdit)
private
FAlignment: TAlignment;
FOldAlignment : TAlignment;
FTextMargin : integer;
FRightNull : Boolean;
function CalcTextMargin : integer;
procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
procedure CMExit(var Message: TCMExit); message CM_EXIT;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure SetAlignment(Value: TAlignment);
protected
property Alignment: TAlignment read FAlignment write SetAlignment default taRightJustify;
property RightNull: Boolean read FRightNull write FRightNull default False;
procedure FormatText; dynamic;
procedure UnFormatText; dynamic;
public
constructor Create(AOwner: TComponent); override;
end;
TStrEdit = class (TCustomStrEdit)
published
property Alignment;
property AutoSize;
property BorderStyle;
property CharCase; {KB}
property Color;
property Ctl3D;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property HideSelection;
property MaxLength;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly;
property RightNull; {KB}
property ShowHint;
property TabOrder;
property Visible;
property OnChange;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;
type
TNumericType = (ntGeneral, ntCurrency, ntPercentage);
TMaskString = string [25];
{ mask component }
type
TMasks = class (TPersistent)
private
FPositiveMask : TMaskString;
FNegativeMask : TMaskString;
FZeroMask : TMaskString;
FOnChange: TNotifyEvent;
protected
procedure SetPositiveMask (Value : TMaskString);
procedure SetNegativeMask (Value : TMaskString);
procedure SetZeroMask (Value : TMaskString);
public
constructor Create;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
published
property PositiveMask : TMaskString read FPositiveMask write SetPositiveMask;
property NegativeMask : TMaskString read FNegativeMask write SetNegativeMask;
property ZeroMask : TMaskString read FZeroMask write SetZeroMask;
end;
{ num edit component }
type
TCustomNumEdit = class (TCustomStrEdit)
private
FDecimals : word;
FDigits : word;
FMasks : TMasks;
FMax : extended;
FMin : extended;
FNumericType : TNumericType;
FUseRounding : boolean;
FValue : extended;
FValidate : boolean;
procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
procedure CMExit(var Message: TCMExit); message CM_EXIT;
procedure SetDecimals(Value : word);
procedure SetDigits(Value : word);
procedure SetMasks (Mask : TMasks);
procedure SetMax(Value : extended);
procedure SetMin(Value : extended);
procedure SetNumericType(Value : TNumericType);
procedure SetValue(Value : extended);
procedure SetValidate(Value : boolean);
protected
procedure FormatText; dynamic;
procedure KeyPress(var Key: Char); override;
procedure UnFormatText; dynamic;
property Decimals : word read FDecimals write SetDecimals;
property Digits : word read FDigits write SetDigits;
property Masks : TMasks read FMasks write SetMasks;
property Max : extended read FMax write SetMax;
property Min : extended read FMin write SetMin;
property NumericType : TNumericType read FNumericType write SetNumericType default ntCurrency;
property UseRounding : boolean read FUseRounding write FUseRounding;
property Value : extended read FValue write SetValue;
property Validate : boolean read FValidate write SetValidate;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function AsDouble : double; dynamic;
function AsInteger : integer; dynamic;
function AsLongint : longint; dynamic;
function AsReal : real; dynamic;
function AsString : string; dynamic;
procedure MaskChanged ( Sender : TObject );
function Valid ( Value : extended ) : boolean; dynamic;
end;
TNumEdit = class (TCustomNumEdit)
published
property AutoSize;
property BorderStyle;
property Color;
property Ctl3D;
property Decimals;
property Digits;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property HideSelection;
property Masks;
property Max;
property Min;
property NumericType;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly;
property ShowHint;
property TabOrder;
property UseRounding;
property Value;
property Validate;
property Visible;
property OnChange;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;
implementation
type
TSetOfChar = set of char;
var
OldMaxLength : integer;
{========================================================================}
{ support routines }
{========================================================================}
function Power ( X, Y : integer ) : real;
begin
Result := exp ( ln ( X ) * Y );
end;
function StripChars ( const Text : string; ValidChars : TSetOfChar ) : string;
var
S : string;
i : integer;
Negative : boolean;
Begin
Negative := false;
if (Text [ 1 ] = '-') or (Text [length (Text)] = '-' ) then
Negative := true;
S := '';
for i := 1 to length ( Text ) do
if Text [ i ] in ValidChars then
S := S + Text [ i ];
if Negative then
Result := '-' + S
else
Result := S;
End;
{========================================================================}
{ Custom String Edit }
{========================================================================}
constructor TCustomStrEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FAlignment := taLeftJustify;
FTextMargin := CalcTextMargin;
end;
function TCustomStrEdit.CalcTextMargin : integer;
{borrowed from TDBEdit}
{calculates a pixel offset from the edge of the control to the text(a margin)}
{used in the paint routine}
var
DC: HDC;
SaveFont: HFont;
I: Integer;
SysMetrics, Metrics: TTextMetric;
begin
DC := GetDC(0);
GetTextMetrics(DC, SysMetrics);
SaveFont := SelectObject(DC, Font.Handle);
GetTextMetrics(DC, Metrics);
SelectObject(DC, SaveFont);
ReleaseDC(0, DC);
I := SysMetrics.tmHeight;
if I > Metrics.tmHeight then
I := Metrics.tmHeight;
Result := I div 4;
end;
procedure TCustomStrEdit.SetAlignment(Value: TAlignment);
begin
if FAlignment <> Value then
begin
FAlignment := Value;
Invalidate;
end;
end;
procedure TCustomStrEdit.CMEnter(var Message: TCMEnter);
begin
if FRightNull then UnformatText;
inherited;
FOldAlignment := FAlignment;
Alignment := taLeftJustify;
end;
procedure TCustomStrEdit.CMExit(var Message: TCMExit);
begin
if FRightNull then FormatText;
inherited;
Alignment := FOldAlignment;
end;
Procedure TCustomStrEdit.UnformatText;
begin
Text := StripChars ( Text, [ '0'..'9', DecimalSeparator, ThousandSeparator ] );
end;
procedure TCustomStrEdit.FormatText;
var Txt: String;
begin
Txt:= Text;
while Length(Txt) < MaxLength do Txt:= '0'+Txt;
Text:= Txt;
end;
procedure TCustomStrEdit.WMPaint(var Message: TWMPaint);
{borrowed from TDBEdit}
{paints the text in the appropriate position}
var
Width, Indent, Left, I: Integer;
R: TRect;
DC: HDC;
PS: TPaintStruct;
S: string;
Canvas: TControlCanvas;
begin
{let the existing code handle left justify}
if (FAlignment = taLeftJustify) then
begin
inherited;
Exit;
end;
try
Canvas := TControlCanvas.Create;
Canvas.Control := Self;
DC := Message.DC;
if DC = 0 then
DC := BeginPaint(Handle, PS);
Canvas.Handle := DC;
Canvas.Font := Font;
with Canvas do
begin
R := ClientRect;
if (BorderStyle = bsSingle) then
begin
Brush.Color := clWindowFrame;
FrameRect(R);
InflateRect(R, -1, -1);
end;
Brush.Color := Color;
S := Text;
Width := TextWidth(S);
if BorderStyle = bsNone then
Indent := 0
else
Indent := FTextMargin;
if FAlignment = taRightJustify then
Left := R.Right - Width - Indent
else
Left := (R.Left + R.Right - Width) div 2;
TextRect(R, Left, Indent, S);
end;
finally
Canvas.Handle := 0;
if Message.DC = 0 then
EndPaint(Handle, PS);
end;{try}
end;
{========================================================================}
{ Masks object }
{========================================================================}
constructor TMasks.Create;
begin
inherited Create;
FPositiveMask := '#.##0';
FNegativeMask := '';
FZeroMask := '';
end;
procedure TMasks.SetPositiveMask (Value : TMaskString);
begin
if FPositiveMask <> Value then
begin
FPositiveMask := Value;
OnChange(Self);
end;
end;
procedure TMasks.SetNegativeMask (Value : TMaskString);
begin
if FNegativeMask <> Value then
begin
FNegativeMask := Value;
OnChange(Self);
end;
end;
procedure TMasks.SetZeroMask (Value : TMaskString);
begin
if FZeroMask <> Value then
begin
FZeroMask := Value;
OnChange(Self);
end;
end;
{========================================================================}
{ Custom Numeric Edit }
{========================================================================}
constructor TCustomNumEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 85;
FAlignment := taRightJustify;
FNumericType := ntCurrency;
FDigits := 12;
FDecimals := 2;
AutoSelect := true;
FMax := 0.0;
FMin := 0.0;
FValidate := false;
FValue := 0.0;
FormatText;
FTextMargin := CalcTextMargin;
FUseRounding := true;
FMasks := TMasks.Create;
FMasks.OnChange := MaskChanged;
DecimalSeparator := '.';
ThousandSeparator := ',';
end;
destructor TCustomNumEdit.Destroy;
begin
FMasks.Free;
inherited Destroy;
end;
function TCustomNumEdit.AsInteger : integer;
const
MaxInteger : integer = 32767;
MinInteger : integer = -32768;
begin
Result := 0;
if (FValue < MaxInteger) and (FValue > MinInteger) then
if FUseRounding then
Result := round ( FValue )
else
Result := trunc ( FValue );
end;
function TCustomNumEdit.AsLongint : longint;
const
MaxLongint : longint = 2147483647;
MinLongint : longint = -2147483647;
begin
Result := 0;
if (FValue < MaxLongint ) and (FValue > MinLongint) then
if FUseRounding then
Result := round ( FValue )
else
Result := trunc ( FValue );
end;
function TCustomNumEdit.AsReal : real;
const
MaxReal : real = 1.7E38;
MinReal : real = -1.7E38;
begin
Result := 0;
if (FValue < MaxReal) and (FValue > MinReal) then
Result := FValue;
end;
function TCustomNumEdit.AsDouble : double;
const
MaxDouble : double = 1.7E308;
MinDouble : double = -1.7E308;
begin
Result := 0;
if (FValue < MaxDouble) and (FValue > MinDouble) then
Result := round ( FValue );
end;
function TCustomNumEdit.AsString : string;
const
ValidChars = [ '0'..'9', ',', '.' ];
begin
Result := StripChars ( Text, ValidChars );
if Value < 0 then
Result := '-' + Result;
end;
procedure TCustomNumEdit.SetMasks (Mask : TMasks);
begin
if fMasks <> Mask then
begin
fMasks := Masks;
Invalidate;
end;
end;
procedure TCustomNumEdit.SetMin(Value : extended);
begin
if FMin <> Value then
begin
FMin := Value;
if FValue < FMin then
FValue := FMin;
end;
end;
procedure TCustomNumEdit.SetMax(Value : extended);
begin
if FMax <> Value then
begin
FMax := Value;
if FValue > FMax then
FValue := FMax;
end;
end;
procedure TCustomNumEdit.SetValue(Value : extended);
begin
if ( FValue <> Value ) and ( Valid ( Value ) ) then
begin
FValue := Value;
FormatText;
end;
end;
procedure TCustomNumEdit.SetDigits(Value : word);
begin
if FDigits <> Value then
begin
FDigits := Value;
FormatText;
end;
end;
procedure TCustomNumEdit.SetDecimals (Value : word);
var NStr: TMaskString;
i : Integer;
begin
if FDecimals <> Value then begin
FDecimals := Value;
FormatText;
if csDesigning in ComponentState then begin
NStr:= '';
i:= 0;
if FDecimals > Digits then Digits:= Decimals + 1;
While i < Digits - Decimals - 1 do begin
NStr:= NStr + '#';
Inc(i);
end;
NStr:= NStr + '0';
if (Decimals > 0) then begin
NStr:= NStr + '.';
i:= 0;
While i < Decimals - 1 do begin
NStr:= NStr + '#';
inc(i);
end;
NStr:= NStr + '0';
end;
Masks.PositiveMask:= NStr;
end;
end;
end;
procedure TCustomNumEdit.SetNumericType(Value: TNumericType);
begin
if FNumericType <> Value then
begin
FNumericType := Value;
FormatText;
end;
end;
procedure TCustomNumEdit.SetValidate(Value : boolean);
begin
if FValidate <> Value then
begin
FValidate:= Value;
if FValidate and (( FValue < FMin ) or ( FValue > FMax )) then
begin
FValue := FMin;
FormatText;
end;
end;
end;
function TCustomNumEdit.Valid ( Value : extended ) : boolean;
var
S : string [80];
begin
Result := true;
if Validate and (( Value < FMin ) or ( Value > FMax )) then
begin
FmtStr( S, 'Der eingegebene Wert mu▀ zwischen %g und %g liegen', [FMin, FMax]);
MessageDlg(S,mtError, [mbOk], 0);
Result := false;
end;
end;
procedure TCustomNumEdit.KeyPress(var Key: Char);
begin
{only allow numerics, commas and one period}
if (Key = DecimalSeparator) and (pos (DecimalSeparator, Text) = 0) then
begin
inherited KeyPress(Key);
MaxLength := MaxLength + 1;
end
else
if ( Key = '-' ) and ( pos ( '-', Text ) = 0 ) then
begin
inherited KeyPress(Key);
MaxLength := MaxLength + 1;
end
else
if Key in [ '0'..'9', ThousandSeparator, #8 ] then
inherited KeyPress(Key)
else
Key := #0;
end;
procedure TCustomNumEdit.CMEnter(var Message: TCMEnter);
begin
{strip the mask and left justify the field}
UnFormatText;
OldMaxLength := MaxLength;
MaxLength := FDigits;
inherited;
end;
procedure TCustomNumEdit.CMExit(var Message: TCMExit);
var
S : string [80];
X : extended;
begin
{format the string with the mask when leaving the field}
MaxLength := OldMaxLength;
S := StripChars (Text, [ '0'..'9', DecimalSeparator ]); {remove all literal characters}
if S = '' then
X := 0.0
else
X := StrToFloat ( S );
if Valid ( X ) then
begin
if FNumericType = ntPercentage then
FValue := X / 100
else
FValue := X;
FormatText;
inherited;
end
else
begin
SelectAll;
SetFocus;
end;
end;
procedure TCustomNumEdit.FormatText;
var
X : extended;
Multiplier : real;
begin
{round the number appropriately}
try
Multiplier := Power ( 10, Decimals );
if FNumericType = ntPercentage then
X := FValue * 100
else
X := FValue;
if UseRounding then
X := round ( X * Multiplier ) / Multiplier
else
X := trunc ( X * Multiplier ) / Multiplier;
except
on ERangeError do
X := FValue; {will cause rounding in the FloatToStr function}
end;
{format the number}
case FNumericType of
ntCurrency : Text := FloatToStrF ( X, ffCurrency, FDigits, FDecimals);
ntPercentage : Text := FloatToStrF ( X, ffFixed, FDigits, FDecimals) + '%';
ntGeneral : with Masks do
Text := FormatFloat( PositiveMask+';'+NegativeMask+';'+ZeroMask, X);
end;
end;
procedure TCustomNumEdit.MaskChanged ( Sender : TObject );
begin
FormatText;
end;
procedure TCustomNumEdit.UnFormatText;
Begin
Text := StripChars ( Text, [ '0'..'9', DecimalSeparator, ThousandSeparator ] );
if Value < 0 then
Text := '-' + Text;
End;
End.